;;;-----------------------------------------------------------------------;
;;;  -*- Syntax: Common-Lisp; Package: USER; Base: 10; Mode: LISP -*-
;;;-----------------------------------------------------------------------;
;;;
;;; Last Modified              18-Jun-93, 15:11
;;;
;;;         File: tool/print-nested-structure.lisp
;;; File created: 30-Jan-91
;;;      Package: USER
;;;       Author: Alex Franz [amf@cs.cmu.edu]
;;;   
;;; File Description: Print nested structures nicely and cheaply
;;;                   line by line (so that we can print into heml*ck
;;;                   buffers within an ordinary mortal's lifetime)
;;;  
;;;-----------------------------------------------------------------------;
;;;
;;; Change Log:
;;; -----------
;;;
;;; 30-Jan-91 by amf: file created from ehn's original code
;;;                   added frame-x stuff for frames
;;;                   added and changed code for efficiency
;;;
;;;  1-Feb-91 by amf: completely rewritten
;;; 
;;;  4-Feb-91 by amf: improved version should stop crashing
;;;                   on weird structures
;;;
;;;  23-Jun-91 by amf: changed to print into a one-line buffer,
;;;                    and only print full buffer when we get a newline
;;;
;;;  5-May-92 by amf: added option to return all output in string
;;;
;;;-----------------------------------------------------------------------;


;;;-----------------------------------------------------------------------;
;;; Documentation                                                         ;
;;;-----------------------------------------------------------------------;

;;; The purpose of this code is to print nested structures
;;; as neatly and cheaply as possible.
;;;
;;; We recognize 1. frames, 2. f-structures, 3. other structs.
;;;
;;; There is no guarantee that other structs will be printed nicely.
;;;
;;; 1. Frame: (Symbol
;;;              (Slot Value)
;;;                   :
;;;              (Slot Value))
;;;
;;; 2. F-structure: ((Slot Value)
;;;                       :
;;;                  (Slot Value))
;;;
;;;
;;; 3. Other struct is anything else.
;;;
;;;
;;; We also recognize to special types of values,
;;; multiple and or, for sets and embedded disjunction, resp.
;;;
;;; These look like frames:
;;;
;;;  (Random-Slot (*OR* Value Value Value))
;;;
;;;  (Random-Slot (*MULTIPLE* Value Value Value))
;;;
;;; These two types are treated especially, i.e. we don't mistake
;;; them for frames.

;;;-----------------------------------------------------------------------;
;;; Package Statements:                                                   ;
;;;-----------------------------------------------------------------------;

(in-package 'user)
;;; (use-package 'meister)


;;;-----------------------------------------------------------------------;
;;; Global Variables:                                                     ;
;;;-----------------------------------------------------------------------;

(defvar *pns-hidden-slots* NIL)

(defvar *pns-indent* 2 "indent after slot")
(defvar *pns-frame-indent* 2 "indent after frame name")

(defvar *pns-max-columns* 70 "width of output stream")
(defvar *pns-expr-length* 15 "less than this much left on line
                                    forces newline")

(defvar *pns-line-buffer* (make-array 20000 :fill-pointer 0 :adjustable t :element-type 'string-char))

(defvar *pns-buffer-output?* t "if t, will buffer output one full line")

(defvar *pns-to-string?* nil "if t, will return one big string")
 
(defconstant *pns-max-indent* 190)

(defconstant *pns-space-string* (make-string 190 :initial-element #\space))

(defconstant *pns-nil-string* "NIL")

(defconstant *pns-multiple-list-opener-string* " (*MULTIPLE*")

(defconstant *pns-or-list-opener-string* " (*OR*")


;;;-----------------------------------------------------------------------;
;;; Macros:                                                               ;
;;;-----------------------------------------------------------------------;

;;; macros for one-line buffer

(defmacro add-char-to-buffer (char)
  `(vector-push-extend ,char *pns-line-buffer*))

;;; use add-string-to-buffer instead
;
;(defmacro add-char-vector-to-buffer (char-vector)
;  `(dotimes (i (length ,char-vector))
;    (add-char-to-buffer (aref ,char-vector i))))
 
(defmacro add-string-to-buffer (string)
  `(dotimes (i (length ,string))
    (add-char-to-buffer (char ,string i))))

;;; macros for finding out what type of item we have

(defmacro atomic-p (thing)
  `(or
    (null ,thing)
    (not (listp ,thing))))

(defmacro attrib-val-atomic-pair-p (thing)
  `(and
    (listp ,thing)
    (atomic-p (first ,thing))
    (atomic-p (second ,thing))
    (second ,thing) 	 ; shouldn't be NIL
    (and (= (length ,thing) 2)
;         (null (cddr ,thing))
     )))
     

;;;  9-Jul-93 by jrrl: changed to handle listed with dotted ends.

;;;    (not (third ,thing))

    

(defmacro frame-name-p (thing)
  `(atomic-p ,thing))

(defmacro pns-frame-p (thing)
  `(and (listp ,thing)
        (frame-name-p (first ,thing))))

(defmacro f-structure-p (thing)
  `(and (listp ,thing)
	(every #'listp ,thing)))

(defmacro multiple-slot-p (thing)
  `(and (listp ,thing)
	(eq '*multiple* (first ,thing))))

(defmacro or-slot-p (thing)
  `(and (listp ,thing)
	(eq '*or* (first ,thing))))

(defmacro list-of-atoms-p (thing)
  `(and (listp ,thing)
	(every #'(lambda (x) (atomic-p x)) ,thing)))

(defmacro small-enough-p (thing)
  `(or (atomic-p ,thing)
       (let ((x (rest ,thing)))
	 (or (null x)
	     (atomic-p (first x))))))

;;;-----------------------------------------------------------------------;
;;; Inline Functions:                                                     ;
;;;-----------------------------------------------------------------------;

(proclaim '(inline pns-print-open-paren pns-print-close-paren pns-print-one-space
            pns-print-nil pns-newline pns-print-space-or-newline
            pns-print-atom pns-print-spaces))


(defun pns-print-open-paren (stream)
  (if *pns-buffer-output?*
      (add-char-to-buffer #\( ) ; then 
      (write-char #\( stream))) ; else

(defun pns-print-close-paren (stream)
  (if *pns-buffer-output?*
      (add-char-to-buffer #\) ) ; then 
      (write-char #\) stream))) ; else

(defun pns-print-one-space (stream)
  (if *pns-buffer-output?*
      (add-char-to-buffer #\space ) ; then
      (write-char #\space stream))) ; else

(defun pns-print-one-dot (stream)
  (if *pns-buffer-output?*
      (add-char-to-buffer #\. ) ; then
      (write-char #\. stream))) ; else

(defun pns-print-nil (stream)
  (if *pns-buffer-output?*
      (add-string-to-buffer *pns-nil-string*) ; then
      (write-string *pns-nil-string* stream)))     ; else

(defun pns-print-spaces (k stream)
  (cond (*pns-buffer-output?*
	 (dotimes (i k)                 ; then
	   (declare (ignore i))
	   (add-char-to-buffer #\space)))
	(t 
	 (write-string *pns-space-string* stream ; else
		       :start 0
		       :end (min k *pns-max-indent*))))
  (values))

	  
(defun pns-newline (indent stream)
   (cond ((and *pns-buffer-output?* ; buffering all output
	       *pns-to-string?*)
	 ;; add return to buffer
	 (add-char-to-buffer #\newline))

	(*pns-buffer-output?*  ; just buffering per line
	 ;; write out the buffer
	 (write *pns-line-buffer* :stream stream :escape nil)
	 ;; reset the line buffer
	 (setf (fill-pointer *pns-line-buffer*) 0)
	 (terpri stream))

	(t ; not buffering at all
	 (terpri stream)))
  ;; add spaces to bufer
  (pns-print-spaces indent stream)
  (values indent))


(defun pns-print-space-or-newline (indent column stream)
  (cond ((>  *pns-expr-length*      
	     (- *pns-max-columns* column)) ; not enough left
	 (pns-newline indent stream))
	(t
	 (pns-print-one-space stream)
	 (1+ column))))


(defun pns-print-atom (atom stream column)
  (let ((string (write-to-string atom :escape t)))
    (if *pns-buffer-output?*
	(add-string-to-buffer string) ; then
	(write-string string stream)) ; else
    (+ column (length string))))


;;;-----------------------------------------------------------------------;
;;; Functions:                                                            ;
;;;-----------------------------------------------------------------------;

;;;-----------------------------------------------------------------------;
;;; Function PNS
;;;
;;; entry point for printing nested structure

(defun pns (thing &key
		  (stream *standard-output*)		  
		  (max-column *pns-max-columns*)
		  (newline t)    ; whether to start on new line
		  (indent 0))
  (let* ((*pns-max-columns* max-column)
	 (*print-pretty* nil)
	 (*pns-to-string?* (not stream))
	 (*pns-buffer-output?* (or *pns-to-string?*
			       *pns-buffer-output?*))
	 column)
    (setf (fill-pointer *pns-line-buffer*) 0)
    (setq column (pns-recursive thing stream indent 1 :f-newline newline))
    ;;; flush buffer, if used

    (cond ((and *pns-buffer-output?* ; buffering all output    
	       *pns-to-string?*)
	   ;; just return entire buffer
	   (values *pns-line-buffer* column))

	  (*pns-buffer-output?*  ; just buffering per line
	   (write *pns-line-buffer* :stream stream :escape nil)
	   (setf (fill-pointer *pns-line-buffer*) 0)
	   (values column))

	(t ; not buffering at all
	 (values column)))))
		

(defun pns-recursive (thing stream indent column &key (f-newline t))
  ;; f-newline nil tell sprint-frame, print-fs not to newline
  (cond ((null thing)
	 (pns-print-nil stream)
	 (+ column 3))		; return column
	((atomic-p thing)
	 (pns-print-atom thing stream column))
    	((multiple-slot-p thing) 
	 (print-multiple thing stream indent column))
	((or-slot-p thing)
	 (print-or thing stream indent column))
	((pns-frame-p thing)		
	 (pns-frame thing stream indent column :newline f-newline))
	(t				; treat like an f-structure
	 (pns-fs thing stream indent column :newline f-newline))))

  
;;; FS always start on a new line.
;;; Then, we print all feature-value pairs with as few newlines
;;; as possible.

(defun pns-fs (fs stream indent column &key (newline t))
  (let ((beg-of-line t))
    (multiple-value-bind
	  (symbols feats fss) (sort-ns-slots fs)
      ;; since this is a fs, symbols should be empty...
      (if newline
	  (setq column (pns-newline indent stream)))
      (pns-print-open-paren stream)
      (incf column)
      (incf indent)
      ;; print all symbols on one line
      (when symbols
	(dolist (symbol symbols)
	  (unless beg-of-line
	    (setq column (pns-print-space-or-newline indent column stream)))
	  (setq column (pns-print-atom symbol stream column))
	  (setq beg-of-line nil)))
      ;; print all top-level features on one line
      (when feats
	(dolist (slot feats)
	  (unless beg-of-line
	    (setq column (pns-print-space-or-newline indent column stream)))
	  (setq column (pns-slot slot stream indent column))
	  (setq beg-of-line nil)))
      ;; then print rest of FS, multiples, and ors
      (dolist (slot fss)
	(unless beg-of-line
	  (setq column (pns-newline indent stream)))
	(setq column (pns-slot slot stream indent column))
	(setq beg-of-line nil))
      ;; close off feature structure
      (pns-print-close-paren stream)
      (incf column))))

;;; Frames always start on a new line.
;;; Then, we print the slot-value pairs 
;;; on a separate line.

(defun pns-frame (frame stream indent column &key (newline t))
  (let ((beg-of-line t))
    (multiple-value-bind
	  (symbols feats fss) (sort-ns-slots frame)
      (let ((framebody (nconc feats fss)))
	;; since this is a frame, there should be at least
	;; one symbol...
	(if newline
	    (setq column (pns-newline indent stream)))
	(pns-print-open-paren stream)
	(incf column)
	(incf indent)
	;; print all symbols (=frame names) on one line
	(when symbols
	  (dolist (symbol symbols)
	    (unless beg-of-line 
	      (setq column (pns-print-space-or-newline indent column stream)))
	    (setq column (pns-print-atom symbol stream column))
	    (setq beg-of-line nil)))
	;; then print rest of FS, multiples, and ors
	(dolist (slot framebody)	
	  (setq column (pns-newline (+ *pns-frame-indent* indent)  stream))
	  (setq column (pns-slot slot stream (+ *pns-frame-indent* indent)
				 column)))
	;; close off feature structure
	(pns-print-close-paren stream)
	(incf column)))))


;;;-----------------------------------------------------------------------;
;;; Function PNS-SLOT:
;;;
;;; Print a single slot of a nested structure

(defun pns-slot (slot stream indent column)

  (cond ((atomic-p slot)		; truly weird and random structure
	 (pns-recursive slot stream indent column))
	((or-slot-p (second slot))
	 (pns-print-open-paren stream)
	 (incf column)
	 (incf indent)
	 (setq column (pns-print-atom (first slot) stream column))

	 (setq column (print-or (second slot)
				stream (+ indent *pns-indent*) column
				:newline t))
	 (pns-print-close-paren stream)
	 (1+ column))
	((multiple-slot-p (second slot))
	 (pns-print-open-paren stream)
	 (incf column)
	 (incf indent)
	 (setq column (pns-print-atom (first slot) stream column))
	 (setq column (print-multiple (second slot)
				      stream (+ indent *pns-indent*) column
				      :newline t))
	 (pns-print-close-paren stream)
	 (1+ column))
	((attrib-val-atomic-pair-p slot)
	 (pns-print-open-paren stream)
	 (incf column)
	 (incf indent)
	 (setq column (pns-print-atom (first slot) stream column))
	 (pns-print-one-space stream)
	 (incf column)
	 (setq column (pns-print-atom (second slot) stream column))
	 (when (cddr slot)
	   (pns-print-one-space stream)
	   (pns-print-one-dot   stream)
	   (pns-print-one-space stream)
	   (incf column 3)
	   (setq column (pns-print-atom (cddr slot) stream column)))
	 (pns-print-close-paren stream)
	 (1+ column))
	((frame-name-p slot)
	 ;; this should only happen if we're confused
	 (pns-print-atom slot stream column))
	((or (cddr slot)
	     (and (listp slot)
		  (listp (first slot))))
	 (pns-recursive slot stream indent column :f-newline nil))
	((null (second slot)) ; probably nested list
	 (setq column (pns-recursive slot stream indent column :f-newline nil)))
	(t
	 ;;;  9-Jul-93 by jrrl: this needs to allow for dotted pair things!
	 (let ((slot-value (second slot)))
	   (pns-print-open-paren stream)
	   (incf column)
	   (incf indent)
	   (setq column (pns-print-atom (first slot) stream column))
	   (cond ((small-enough-p slot-value)
		  (pns-print-one-space stream)
		  (incf column)
		  (setq column (pns-recursive
				slot-value stream indent column
				:f-newline nil))) ; before frame, FS
				
		 (t (setq column (pns-recursive
				  slot-value
				  stream
				  (+ indent *pns-indent*)
				  column))))

	   ;; close off slots
	   (pns-print-close-paren stream)
	   (1+ column)))))



(defun print-or (or stream indent column &key (newline nil))

  ;; if :newline is non-nil, do a newline unless there is very little stuff
  (if newline
      (unless (list-of-atoms-p (rest or))
	(setq column (pns-newline indent stream))))
  (cond ((list-of-atoms-p (rest or))
	 (pns-print-or-list-opener stream)
	 (incf column 6)
	 (incf indent *pns-indent*)
	 (dolist (s (rest or))
	   (setq column (pns-print-space-or-newline indent column stream))
	   (setq column (pns-print-atom s stream column))))
	(t
	 (pns-print-or-list-opener stream)	 
	 (incf indent *pns-indent*)
	 (dolist (s (rest or))
;;;	   (setq column (pns-newline (+ indent *pns-indent*) stream))
	   (setq column (pns-recursive s stream
				       (+ indent *pns-indent*) column)))))
  (pns-print-close-paren stream)
  (1+ column))



(defun print-multiple (mult stream indent column &key (newline nil))

  ;; if :newline is non-nil, do a newline unless there is very little stuff
  (if newline
      (unless (list-of-atoms-p (rest mult))
	(setq column (pns-newline indent stream))))
  (cond ((list-of-atoms-p (rest mult))
	 (pns-print-multiple-list-opener stream)
	 (incf column 12)
	 (incf indent *pns-indent*)
	 (dolist (s (rest mult))
	   (setq column (pns-print-space-or-newline indent column stream))
	   (setq column (pns-print-atom s stream column))))
	(t
	 (pns-print-multiple-list-opener stream)
	 (incf indent *pns-indent*)
	 (dolist (s (rest mult))
;;;	   (setq column (pns-newline (+ indent *pns-indent*) stream))
	   (setq column (pns-recursive s stream
				       (+ indent *pns-indent*) column)))))
  (pns-print-close-paren stream)
  (1+ column))

;;; the next two aren't called very often, so they're not inlined

(defun pns-print-multiple-list-opener (stream)
  (if *pns-buffer-output?*
      (add-string-to-buffer *pns-multiple-list-opener-string*) ; then
      (write-string *pns-multiple-list-opener-string* stream)))     ; else

(defun pns-print-or-list-opener (stream)
  (if *pns-buffer-output?*
      (add-string-to-buffer *pns-or-list-opener-string*) ; then
      (write-string *pns-or-list-opener-string* stream)))     ; else



;;;-----------------------------------------------------------------------;
;;; sort slots
;;; 
;;; Sort the slots in an f-structure according to the following criteria:
;;;   Features first, then embedded structure.


;;; HELLO: this should be vectorized -- or we shouldn't sort at all

(defmacro push-end (el list)
  `(setf ,list (nconc ,list (list ,el))))

(defun sort-ns-slots (fs)
  "sort slots in structure; returns (values
   symbols single-nested-features others)"
  (let (feats fss mults ors name)
    (dolist (slot fs (values name feats (append fss mults ors)))
      (cond ((and (listp slot)
		  (member (first slot) *pns-hidden-slots*))
	     )                          ; we do noooothing
	    ((frame-name-p slot)
	     (push-end slot name))	; allows multiple names
	    ((multiple-slot-p slot)
	     (push-end slot mults))
	    ((or-slot-p slot)
	     (push-end slot ors))
	    ((attrib-val-atomic-pair-p slot)	    
	     (push-end slot feats))
	    (t (push-end slot fss))))))



;;; to test hemlock action:
;;; (load "/afs/cs.cmu.edu/project/cmt-4/catalyst/working/tool/x11-hemlock-windows")
;;; (setf *hem* (hemlock-window-stream "Aktion"))
